home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Monster Media 1994 #2
/
Monster Media No. 2 (Monster Media)(1994).ISO
/
prog_bas
/
vbint.zip
/
INTDEMO.BAS
< prev
next >
Wrap
BASIC Source File
|
1994-06-04
|
33KB
|
1,222 lines
'---------------------------------------------------------------------------
' DOS Interrupt Demo Program, Copyright (c) 1994 Karl E. Peterson
' Redistributed by permission.
'
' Requires: VBInt.DLL, VBRun300.DLL
'
' This program may be distributed freely on the condition that it is
' distributed in full, and unmodified, and that no fee is charged for such
' distribution with the exception of reasonable media and shipping charges.
' Any or all portions of the source code may be incorporated into your own
' programs, and those programs may be distributed without payment of
' royalties on the condition that such programs differ substantially from
' this demonstration program.
'
' This program is distributed AS IS. The author acknowledges absolutely
' no liability for its use or misuse. The sole purpose of this program is to
' demonstrate some of the powerful capabilities of VBInt.DLL, written and
' copyrighted by Rick Esterling. Calling DOS interrupts from Windows is
' fairly "non-standard" behavior. Users of this program acknowledge that
' they are doing so at their OWN RISK.
'
' This demonstration program was created and distributed by:
' Karl E. Peterson
' Regional Transportation Council
' 1351 Officers' Row
' Vancouver, Washington 98661
' CompuServe: 72302,3707
'
' Your comments or questions are invited!
'---------------------------------------------------------------------------
DefInt A-Z
Option Explicit
Type VBRegs
AX As Integer
BX As Integer
CX As Integer
DX As Integer
SI As Integer
DI As Integer
cFlag As Integer
DS As Integer
ES As Integer
End Type
Declare Function VBInt% Lib "vbint.dll" Alias "#1" (ByVal ServNum%, InRegs As VBRegs, OutRegs As VBRegs)
Declare Function GetSegment% Lib "vbint.dll" Alias "#2" (ByVal IntVar As String)
Declare Function GetOffset% Lib "vbint.dll" Alias "#3" (ByVal IntVar As String)
Declare Function UDTSegment% Lib "vbint.dll" Alias "#2" (IntVar As Any)
Declare Function UDTOffset% Lib "vbint.dll" Alias "#3" (IntVar As Any)
Type FileDataType
FileName As String * 12 'useful for display purposes
sDate As Double
Attr As Integer
Size As Long
name83 As String * 11 'useful for sorting on name
name38 As String * 11 'useful for sorting on extension
year As Integer
month As Integer
day As Integer
hour As Integer
minute As Integer
second As Integer
End Type
Type DiskFreeSpaceType
sectorsPerCluster As Integer
bytesPerSector As Integer
clustersPerDrive As Long
availableClusters As Long
availableBytes As Long
totalBytes As Long
allocationSize As Long
End Type
Type DTAType 'used by DOS file services
Reserved As String * 21 'reserved for use by DOS
Attribute As String * 1 'the file's attribute
FileTime As Integer 'the file's time
FileDate As Integer 'the file's date
FileSize As Long 'the file's size
FileName As String * 13 'the file's name
End Type
Type SerialNumberType
InfoLev As Integer
SerNum As String * 4
Volume As String * 11
SysType As String * 8
End Type
Type ReadWriteBlockType
rwSpecFunc As String * 1
rwHead As Integer
rwCylinder As Integer
rwFirstSector As Integer
rwSectors As Integer
rwBuffer As Long
End Type
Global DosVersion As Integer
'Constants
Global Const attrNormal = 0
Global Const attrReadOnly = 1
Global Const attrHidden = 2
Global Const attrSystem = 4
Global Const attrVolume = 8
Global Const attrDirectory = 16
Global Const attrArchived = 32
Global Const attrAllFile = attrReadOnly + attrHidden + attrSystem + attrArchived
Global Const attrAllDir = attrDirectory + attrHidden + attrReadOnly
Global Const attrAll = attrAllFile + attrDirectory
Global Const attrAllNorm = attrReadOnly + attrArchived + attrDirectory
' MsgBox parameters
Global Const MB_OK = 0 ' OK button only
Global Const MB_OKCANCEL = 1 ' OK and Cancel buttons
Global Const MB_ABORTRETRYIGNORE = 2 ' Abort, Retry, and Ignore buttons
Global Const MB_YESNOCANCEL = 3 ' Yes, No, and Cancel buttons
Global Const MB_YESNO = 4 ' Yes and No buttons
Global Const MB_RETRYCANCEL = 5 ' Retry and Cancel buttons
Global Const MB_ICONSTOP = 16 ' Critical message
Global Const MB_ICONQUESTION = 32 ' Warning query
Global Const MB_ICONEXCLAMATION = 48 ' Warning message
Global Const MB_ICONINFORMATION = 64 ' Information message
Global Const MB_APPLMODAL = 0 ' Application Modal Message Box
Global Const MB_DEFBUTTON1 = 0 ' First button is default
Global Const MB_DEFBUTTON2 = 256 ' Second button is default
Global Const MB_DEFBUTTON3 = 512 ' Third button is default
Global Const MB_SYSTEMMODAL = 4096 'System Modal
' MsgBox return values
Global Const IDOK = 1 ' OK button pressed
Global Const IDCANCEL = 2 ' Cancel button pressed
Global Const IDABORT = 3 ' Abort button pressed
Global Const IDRETRY = 4 ' Retry button pressed
Global Const IDIGNORE = 5 ' Ignore button pressed
Global Const IDYES = 6 ' Yes button pressed
Global Const IDNO = 7 ' No button pressed
' API Calls
Declare Function GetWindowsDirectory Lib "Kernel" (ByVal lpBuffer As String, ByVal nSize As Integer) As Integer
Declare Function GetSystemDirectory Lib "Kernel" (ByVal lpBuffer As String, ByVal nSize As Integer) As Integer
Declare Function GetVersion Lib "Kernel" () As Long
Declare Function GetWinFlags Lib "Kernel" () As Long
Declare Function SendMessage Lib "User" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As Long
' Private Window Messages Start Here:
Global Const WM_USER = &H400
' Listbox messages
Global Const LB_ADDSTRING = (WM_USER + 1)
Global Const LB_INSERTSTRING = (WM_USER + 2)
Global Const LB_DELETESTRING = (WM_USER + 3)
Global Const LB_RESETCONTENT = (WM_USER + 5)
Global Const LB_SETSEL = (WM_USER + 6)
Global Const LB_SETCURSEL = (WM_USER + 7)
Global Const LB_GETSEL = (WM_USER + 8)
Global Const LB_GETCURSEL = (WM_USER + 9)
Global Const LB_GETTEXT = (WM_USER + 10)
Global Const LB_GETTEXTLEN = (WM_USER + 11)
Global Const LB_GETCOUNT = (WM_USER + 12)
Global Const LB_SELECTSTRING = (WM_USER + 13)
Global Const LB_DIR = (WM_USER + 14)
Global Const LB_GETTOPINDEX = (WM_USER + 15)
Global Const LB_FINDSTRING = (WM_USER + 16)
Global Const LB_GETSELCOUNT = (WM_USER + 17)
Global Const LB_GETSELITEMS = (WM_USER + 18)
Global Const LB_SETTABSTOPS = (WM_USER + 19)
Global Const LB_GETHORIZONTALEXTENT = (WM_USER + 20)
Global Const LB_SETHORIZONTALEXTENT = (WM_USER + 21)
Global Const LB_SETCOLUMNWIDTH = (WM_USER + 22)
Global Const LB_SETTOPINDEX = (WM_USER + 24)
Global Const LB_GETITEMRECT = (WM_USER + 25)
Global Const LB_GETITEMDATA = (WM_USER + 26)
Global Const LB_SETITEMDATA = (WM_USER + 27)
Global Const LB_SELITEMRANGE = (WM_USER + 28)
Global Const LB_MSGMAX = (WM_USER + 33)
' Constants used with GetWinFlags()
Global Const WF_PMODE = &H1
Global Const WF_CPU286 = &H2
Global Const WF_CPU386 = &H4
Global Const WF_CPU486 = &H8
Global Const WF_STANDARD = &H10
Global Const WF_WIN286 = &H10
Global Const WF_ENHANCED = &H20
Global Const WF_WIN386 = &H20
Global Const WF_CPU086 = &H40
Global Const WF_CPU186 = &H80
Global Const WF_80x87 = &H400
Global Const WF_CPUR4000 = &H100
Global Const WF_CPUALPHA21064 = &H200
Global Const WF_WINNT = &H4000
Function DosAnsiLoaded ()
Dim Regs As VBRegs, Rtn%, AH%, AL%
Regs.AX = &H1A00
Rtn% = VBInt(&H2F, Regs, Regs)
WordSplit Regs.AX, AH, AL
If AL = &HFF Then
DosAnsiLoaded = True
Else
DosAnsiLoaded = False
End If
End Function
Function DosAppendLoaded ()
Dim Regs As VBRegs, Rtn%, AH%, AL%
Regs.AX = &H2F00
Rtn% = VBInt(&H2F, Regs, Regs)
WordSplit Regs.AX, AH, AL
If AL = &HFF Then
DosAppendLoaded = True
Else
DosAppendLoaded = False
End If
End Function
Function DosAssignLoaded ()
Dim Regs As VBRegs, Rtn%, AH%, AL%
Regs.AX = &H600
Rtn% = VBInt(&H2F, Regs, Regs)
WordSplit Regs.AX, AH, AL
If AL = &HFF Then
DosAssignLoaded = True
Else
DosAssignLoaded = False
End If
End Function
Function DosDblSpaceLoaded ()
Dim Regs As VBRegs, Rtn%, CH%, CL%
Regs.AX = &H4A11
Regs.BX = 0
Rtn% = VBInt(&H2F, Regs, Regs)
If Regs.AX = &H0 And Regs.BX = &H444D Then
DosDblSpaceLoaded = True
'CL = First drive letter used by DoubleSpace (0-based)
'CH = Number of drive letters used by DoubleSpace
'DX = DBLSPACE.BIN version number; this is an internal version number
' which is used by DBLSPACE.BIN, IO.SYS, and DBLSPACE.EXE to
' ensure that their interfaces are consistent.
WordSplit Regs.CX, CH, CL
Else
DosDblSpaceLoaded = False
End If
End Function
Function DosDosKeyLoaded ()
Dim Regs As VBRegs, Rtn%, AH%, AL%
Regs.AX = &H4800
Rtn% = VBInt(&H2F, Regs, Regs)
WordSplit Regs.AX, AH, AL
If AL = &H0 Then
DosDosKeyLoaded = False
Else
DosDosKeyLoaded = True
End If
End Function
Function DosErrorMsg$ (ErrorCode%)
Dim t$
Select Case ErrorCode
Case 0: t$ = ""
Case 1: t$ = "Function Number Invalid"
Case 2: t$ = "File Not Found"
Case 3: t$ = "Path Not Found"
Case 4: t$ = "Too Many Open Files"
Case 5: t$ = "Access Denied"
Case 6: t$ = "Handle Invalid"
Case 7: t$ = "Memory Control Block Invalid"
Case 8: t$ = "Insufficient Memory"
Case 9: t$ = "Memory Block Address Invalid"
Case 10: t$ = "Environment Invalid"
Case 11: t$ = "Format Invalid"
Case 12: t$ = "Access Code Invalid"
Case 13: t$ = "Data Invalid"
Case 14: t$ = "Unknown Unit"
Case 15: t$ = "Disk Drive Invalid"
Case 16: t$ = "Attempted to Remove Current Directory"
Case 17: t$ = "Not Same Device"
Case 18: t$ = "No More Files"
Case 19: t$ = "Disk Write Protected"
Case 20: t$ = "Unknown Unit"
Case 21: t$ = "Drive Not Ready"
Case 22: t$ = "Unknown Command"
Case 23: t$ = "Data Error (CRC)"
Case 24: t$ = "Bad Request Structure Length"
Case 25: t$ = "Seek Error"
Case 26: t$ = "Unknown Media Type"
Case 27: t$ = "Sector Not Found"
Case 28: t$ = "Printer Out of Paper"
Case 29: t$ = "Write Fault"
Case 30: t$ = "Read Fault"
Case 31: t$ = "General Failure"
Case 32: t$ = "Sharing Violation"
Case 33: t$ = "Lock Violation"
Case 34: t$ = "Disk Change Invalid"
Case 35: t$ = "FCB Unavailable"
Case 36: t$ = "Sharing Buffer Exceeded"
Case 37 To 49: t$ = "Reserved"
Case 50: t$ = "Unsupported Network Request"
Case 51: t$ = "Remote Machine Not Listening"
Case 52: t$ = "Duplicate Name in Network"
Case 53: t$ = "Network Name not Found"
Case 54: t$ = "Network Busy"
Case 55: t$ = "Device No Longer Exists on Network"
Case 56: t$ = "NetBIOS Command Limit Exceeded"
Case 57: t$ = "Error in Network Adapter Hardware"
Case 58: t$ = "Incorrect Response from Network"
Case 59: t$ = "Unexpected Network Error"
Case 60: t$ = "Remote Adapter Incompatible"
Case 61: t$ = "Print Queue Full"
Case 62: t$ = "Queue Not Full"
Case 63: t$ = "Not Enough Room for Print File"
Case 64: t$ = "Network Name Deleted"
Case 65: t$ = "Access Denied"
Case 66: t$ = "Incorrect Network Device Type"
Case 67: t$ = "Network Name Not Found"
Case 68: t$ = "Network Name Limit Exceeded"
Case 69: t$ = "NetBIOS Session Limit Exceeded"
Case 70: t$ = "Temporary Pause"
Case 71: t$ = "Network Request Not Accepted"
Case 72: t$ = "Print or Disk Redirection Paused"
Case 73 To 79: t$ = "Reserved"
Case 80: t$ = "File Already Exists"
Case 81: t$ = "Reserved"
Case 82: t$ = "Cannot Make Directory"
Case 83: t$ = "Fail on Int 24H (Critical Error)"
Case 84: t$ = "Out of Structures"
Case 85: t$ = "Already Assigned"
Case 86: t$ = "Invalid Password"
Case 87: t$ = "Invalid Parameter"
Case 88: t$ = "Net Write Fault"
Case Else: t$ = "Unknown Error"
End Select
DosErrorMsg$ = t$
End Function
Function DosGetVersion ()
Dim Regs As VBRegs, Rtn%
Regs.AX = &H3000
Rtn% = VBInt(&H21, Regs, Regs)
DosGetVersion = ByteLo(Regs.AX) * 100 + ByteHi(Regs.AX)
End Function
Function DosGraftablLoaded ()
Dim Regs As VBRegs, Rtn%, AH%, AL%
Regs.AX = &HB000
Rtn% = VBInt(&H2F, Regs, Regs)
WordSplit Regs.AX, AH, AL
If AL = &HFF Then
DosGraftablLoaded = True
Else
DosGraftablLoaded = False
End If
End Function
Function DosHimemLoaded ()
Dim Regs As VBRegs, Rtn%, AH%, AL%
Regs.AX = &H4300
Rtn% = VBInt(&H2F, Regs, Regs)
WordSplit Regs.AX, AH, AL
If AL = &H80 Then
DosHimemLoaded = True
Else
DosHimemLoaded = False
End If
End Function
Function DosNetworkLoaded ()
Dim Regs As VBRegs, Rtn%, AH%, AL%
Regs.AX = &H1100
Rtn% = VBInt(&H2F, Regs, Regs)
WordSplit Regs.AX, AH, AL
If AL = &HFF Then
DosNetworkLoaded = True
Else
DosNetworkLoaded = False
End If
End Function
Function DosNlsfuncLoaded ()
Dim Regs As VBRegs, Rtn%, AH%, AL%
Regs.AX = &H1400
Rtn% = VBInt(&H2F, Regs, Regs)
WordSplit Regs.AX, AH, AL
If AL = &HFF Then
DosNlsfuncLoaded = True
Else
DosNlsfuncLoaded = False
End If
End Function
Function DosPrintLoaded ()
Dim Regs As VBRegs, Rtn%, AH%, AL%
Regs.AX = &H100
Rtn% = VBInt(&H2F, Regs, Regs)
WordSplit Regs.AX, AH, AL
If AL = &HFF Then
DosPrintLoaded = True
Else
DosPrintLoaded = False
End If
End Function
Function DosShareLoaded ()
Dim Regs As VBRegs, Rtn%, AH%, AL%
Regs.AX = &H1000
Rtn% = VBInt(&H2F, Regs, Regs)
WordSplit Regs.AX, AH, AL
If AL = &HFF Then
DosShareLoaded = True
Else
DosShareLoaded = False
End If
End Function
Function DrvCDRom (Drive$)
Dim Rtn%, Reg As VBRegs, Buffer$
'Test for MSCDEX first
Reg.AX = &H1500
Rtn% = VBInt(&H2F, Reg, Reg)
If Reg.BX = 0 Then
DrvCDRom = False
Exit Function
End If
'Test drive
Reg.AX = &H150B
If Len(Drive$) Then
Reg.CX = Asc(UCase$(Drive$)) - 65
Else
Reg.CX = Asc(UCase$(CurDir$)) - 65
End If
Rtn% = VBInt(&H2F, Reg, Reg)
DrvCDRom = Reg.AX
End Function
Sub DrvFreeSpace (Drive$, disk As DiskFreeSpaceType)
Dim Regs As VBRegs
Dim Rtn%
Regs.AX = &H3600
If Len(Drive$) Then
Regs.DX = Asc(UCase$(Drive$)) - 64
Else
Regs.DX = 0 'default drive
End If
Rtn% = VBInt(&H21, Regs, Regs)
disk.sectorsPerCluster = Regs.AX
disk.bytesPerSector = Regs.CX
If Regs.DX >= 0 Then
disk.clustersPerDrive = Regs.DX
Else
disk.clustersPerDrive = Regs.DX + 65536
End If
If Regs.BX >= 0 Then
disk.availableClusters = Regs.BX
Else
disk.availableClusters = Regs.BX + 65536
End If
disk.allocationSize = CLng(Regs.AX) * CLng(Regs.CX)
disk.availableBytes = disk.availableClusters * disk.allocationSize
disk.totalBytes = disk.clustersPerDrive * disk.allocationSize
End Sub
Function DrvGetDir% (Drive$, ReturnDir$)
Dim Rtn%, Reg As VBRegs, Buffer$
Reg.AX = &H4700
If Len(Drive$) Then
Reg.DX = Asc(UCase$(Drive$)) - 64
Else
Reg.DX = 0 'default drive
End If
Buffer$ = Space$(128) + Chr$(0)
Reg.DS = GetSegment(Buffer$)
Reg.SI = GetOffset(Buffer$)
Rtn% = VBInt(&H21, Reg, Reg)
If Reg.cFlag Then
ReturnDir$ = DosErrorMsg$(Reg.AX)
DrvGetDir = False
Else
ReturnDir$ = "\" + Left$(Buffer$, InStr(Buffer$, Chr$(0)) - 1)
DrvGetDir = True
End If
End Function
Function DrvGetSerNum (Drive$, SerialNum$)
'Initialization
Dim BootSector$, OEM$, SN$, Vol$, FileSys$, i%
'Read in boot sector
If DrvTrackRead(Drive$, 0, 0, 0, 1, BootSector$) Then
FileSys$ = Mid$(BootSector$, 55, 8)
If InStr(FileSys$, "FAT") = 1 Then
OEM$ = Mid$(BootSector$, 4, 8)
SN$ = Mid$(BootSector$, 40, 4)
Vol$ = Mid$(BootSector$, 44, 11)
For i = 4 To 1 Step -1
SerialNum$ = SerialNum$ + HexFmt2$(Asc(Mid$(SN$, i, 1)))
Next i
SerialNum$ = Left$(SerialNum$, 4) + "-" + Right$(SerialNum$, 4)
DrvGetSerNum = True
Else 'not a DOS drive
DrvGetSerNum = False
End If
Else 'failed to read boot sector
DrvGetSerNum = False
End If
End Function
Function DrvGetVolume$ (Drive$)
Dim Vol$
Vol$ = Drive$
If Len(Vol$) = 0 Then
Vol$ = CurDir$
End If
Vol$ = UCase$(Left$(Vol$, 1)) + ":\*.*"
Dim DTA As DTAType, ErrorCode%, Rtn%
Rtn = FileFindFirst(Vol$, DTA, attrVolume, ErrorCode)
Vol$ = Left$(DTA.FileName, InStr(DTA.FileName, Chr$(0)) - 1)
If InStr(Vol$, ".") Then
Vol$ = Left$(Vol$, 8) + Mid$(Vol$, 10)
End If
DrvGetVolume$ = Vol$
End Function
Function DrvRemote (Drive$)
Dim Regs As VBRegs
Dim Rtn%
Regs.AX = &H4409
If Len(Drive$) Then
Regs.BX = Asc(UCase$(Drive$)) - 64
Else
Regs.BX = 0 'default drive
End If
Rtn% = VBInt(&H21, Regs, Regs)
If Regs.cFlag Then
'error occured (code in AX)
DrvRemote = False
Else
If Regs.DX And (2 ^ 12) Then
DrvRemote = True
Else
DrvRemote = False
End If
End If
End Function
Function DrvRemovable (Drive$)
Dim Regs As VBRegs
Dim Rtn%
Regs.AX = &H4408
If Len(Drive$) Then
Regs.BX = Asc(UCase$(Drive$)) - 64
Else
Regs.BX = 0 'default drive
End If
Rtn% = VBInt(&H21, Regs, Regs)
If Regs.cFlag Then
'error occured (code in AX), assume not removable
DrvRemovable = False
Else
If Regs.AX = 0 Then
DrvRemovable = True
ElseIf Regs.AX = 1 Then
DrvRemovable = False
End If
End If
End Function
Function DrvSetSerNum (Drive$, NewSerialNum&)
'Initialization
Dim BootSector$, OEM$, SN$, Vol$, FileSys$, i%
Dim Lo%, Hi%
'Read in boot sector
If DrvTrackRead(Drive$, 0, 0, 0, 1, BootSector$) Then
FileSys$ = Mid$(BootSector$, 55, 8)
If InStr(FileSys$, "FAT") = 1 Then
SN$ = Mid$(BootSector$, 40, 4)
Hi = WordHi(NewSerialNum)
Lo = WordLo(NewSerialNum)
SN$ = Chr$(ByteLo(Lo)) + Chr$(ByteHi(Lo)) + Chr$(ByteLo(Hi)) + Chr$(ByteHi(Hi))
Mid$(BootSector$, 40, 4) = SN$
If DrvTrackWrite(Drive$, 0, 0, 0, 1, BootSector$) Then
DrvSetSerNum = True
Else
DrvSetSerNum = False
End If
Else 'not a DOS drive
DrvSetSerNum = False
End If
Else 'failed to read boot sector
DrvSetSerNum = False
End If
End Function
Function DrvSetVolume (Drive$, NewVolume$)
'NOT fully functional yet! Only changes boot sector,
'but doesn't affect root directory.
'Initialization
Dim BootSector$, OEM$, SN$, Vol$, FileSys$, i%
Dim Lo%, Hi%
'Read in boot sector
If DrvTrackRead(Drive$, 0, 0, 0, 1, BootSector$) Then
FileSys$ = Mid$(BootSector$, 55, 8)
If InStr(FileSys$, "FAT") = 1 Then
'OEM$ = Mid$(BootSector$, 4, 8)
'SN$ = Mid$(BootSector$, 40, 4)
'Vol$ = Mid$(BootSector$, 44, 11)
Vol$ = Left$(Left$(NewVolume$, 11) + Space$(11), 11)
Mid$(BootSector$, 44, 11) = Vol$
If DrvTrackWrite(Drive$, 0, 0, 0, 1, BootSector$) Then
DrvSetVolume = True
Else
DrvSetVolume = False
End If
Else 'not a DOS drive
DrvSetVolume = False
End If
Else 'failed to read boot sector
DrvSetVolume = False
End If
End Function
Function DrvTrackRead% (Drive$, dHead%, dCyl%, d1Sec%, dNSec%, Buffer$)
Dim Regs As VBRegs
Dim rwBlock As ReadWriteBlockType
Dim disk As DiskFreeSpaceType
Dim BufSeg%, BufOff%
Dim Rtn%
DrvFreeSpace Drive$, disk
Buffer$ = Space$(dNSec * disk.bytesPerSector)
BufSeg = GetSegment(Buffer$)
BufOff = GetOffset(Buffer$)
rwBlock.rwSpecFunc = Chr$(0)
rwBlock.rwHead = dHead
rwBlock.rwCylinder = dCyl
rwBlock.rwFirstSector = d1Sec
rwBlock.rwSectors = dNSec
rwBlock.rwBuffer = BufSeg * 65536 + BufOff
Regs.AX = &H440D
If Len(Drive$) Then
Regs.BX = Asc(UCase$(Drive$)) - 64
Else
Regs.BX = 0 'default drive
End If
Regs.CX = &H861
Regs.DS = UDTSegment(rwBlock)
Regs.DX = UDTOffset(rwBlock)
Rtn% = VBInt(&H21, Regs, Regs)
If Regs.cFlag Then
Buffer$ = DosErrorMsg$(Regs.AX)
DrvTrackRead = False
Else
DrvTrackRead = True
End If
End Function
Function DrvTrackWrite% (Drive$, dHead%, dCyl%, d1Sec%, dNSec%, Buffer$)
Dim Regs As VBRegs
Dim rwBlock As ReadWriteBlockType
Dim disk As DiskFreeSpaceType
Dim BufSeg%, BufOff%
Dim Rtn%
DrvFreeSpace Drive$, disk
If Len(Buffer) <> dNSec * disk.bytesPerSector Then
DrvTrackWrite = False
Exit Function
End If
BufSeg = GetSegment(Buffer$)
BufOff = GetOffset(Buffer$)
rwBlock.rwSpecFunc = Chr$(0)
rwBlock.rwHead = dHead
rwBlock.rwCylinder = dCyl
rwBlock.rwFirstSector = d1Sec
rwBlock.rwSectors = dNSec
rwBlock.rwBuffer = BufSeg * 65536 + BufOff
Regs.AX = &H440D
If Len(Drive$) Then
Regs.BX = Asc(UCase$(Drive$)) - 64
Else
Regs.BX = 0 'default drive
End If
Regs.CX = &H841
Regs.DS = UDTSegment(rwBlock)
Regs.DX = UDTOffset(rwBlock)
Rtn% = VBInt(&H21, Regs, Regs)
If Regs.cFlag Then
Buffer$ = DosErrorMsg$(Regs.AX)
DrvTrackWrite = False
Else
DrvTrackWrite = True
End If
End Function
Function FileExists (FileSpec$) As Integer
'Check for existence using DOS "Search for first match" service &h4E
If Len(FileSpec$) = 0 Or InStr(FileSpec$, "*") > 0 Or InStr(FileSpec$, "?") > 0 Then
FileExists = False
Exit Function
End If
'Initialization
Dim Regs As VBRegs, Rtn%
Dim DtaSeg%, DtaOff%, Spec$
Regs.AX = &H4E00
Regs.CX = attrAll 'Search for all file attributes
Spec$ = FileSpec$ + Chr$(0)
Regs.DS = GetSegment(Spec$)
Regs.DX = GetOffset(Spec$)
Rtn = VBInt(&H21, Regs, Regs)
Select Case Regs.AX
Case 0
FileExists = True
Case Else
FileExists = False
End Select
End Function
Static Function FileFindFirst (Path$, DTA As DTAType, Attribute%, ErrorCode%)
'Initialization
Dim Regs As VBRegs, Rtn%
Dim DtaSeg%, DtaOff%, ThePath$
'The path must be a null terminated string
ThePath$ = Trim$(Path$) + Chr$(0)
'Get current DTA address
Regs.AX = &H2F00
Rtn% = VBInt(&H21, Regs, Regs)
DtaSeg = Regs.ES
DtaOff = Regs.BX
'Set dta address
Regs.AX = &H1A00
Regs.DS = UDTSegment(DTA)
Regs.DX = UDTOffset(DTA)
Rtn% = VBInt(&H21, Regs, Regs)
'Find first file match
Regs.AX = &H4E00
Regs.CX = Attribute
Regs.DS = GetSegment(ThePath$)
Regs.DX = GetOffset(ThePath$)
Rtn% = VBInt(&H21, Regs, Regs)
'The carry flag tells if a file was found or not
If Regs.cFlag And 1 Then 'Carry Flag Set
ErrorCode = Regs.AX
FileFindFirst = False
Else 'Carry Flag Clear
ErrorCode = 0
FileFindFirst = True
End If
'Reset the original DTA
Regs.AX = &H1A00
Regs.DS = DtaSeg
Regs.DX = DtaOff
Rtn% = VBInt(&H21, Regs, Regs)
End Function
Static Function FileFindNext (DTA As DTAType, Attribute%, ErrorCode%)
'NOTE: DTA absolutely *MUST* be initialized by FileFindFirst before calling here!!!
'Initialization
Dim Regs As VBRegs, Rtn%
Dim DtaSeg%, DtaOff%
'Get current DTA address
Regs.AX = &H2F00
Rtn% = VBInt(&H21, Regs, Regs)
DtaSeg = Regs.ES
DtaOff = Regs.BX
'Set DTA address
Regs.AX = &H1A00
Regs.DS = UDTSegment(DTA)
Regs.DX = UDTOffset(DTA)
Rtn% = VBInt(&H21, Regs, Regs)
'Find next file match
Regs.AX = &H4F00
'Regs.CX = Attribute
Rtn% = VBInt(&H21, Regs, Regs)
'The carry flag tells whether a file was found or not
If Regs.cFlag And 1 Then 'Carry Flag Set
ErrorCode = Regs.AX
FileFindNext = False
Else 'Carry Flag Clear
ErrorCode = 0
FileFindNext = True
End If
'Reset the original DTA
Regs.AX = &H1A00
Regs.DS = DtaSeg
Regs.DX = DtaOff
Rtn% = VBInt(&H21, Regs, Regs)
End Function
Static Sub FileGetData (DTA As DTAType, File As FileDataType)
Dim Tim&, Dat&, dot%
File.Attr = Asc(DTA.Attribute)
Tim& = DTA.FileTime
If Tim& < 0 Then Tim& = Tim& + 65536
File.second = Tim& And &H1F
File.minute = (Tim& \ &H20) And &H3F
File.hour = (Tim& \ &H800) And &H1F
Dat& = DTA.FileDate
File.day = Dat& And &H1F
File.month = (Dat& \ &H20) And &HF
File.year = ((Dat& \ &H200) And &H1F) + 1980
File.Size = DTA.FileSize
File.sDate = DateSerial(File.year, File.month, File.day) + TimeSerial(File.hour, File.minute, File.second)
File.FileName = Left$(DTA.FileName, InStr(DTA.FileName, Chr$(0)) - 1)
dot = InStr(File.FileName, ".")
If dot Then
File.name83 = Left$(File.FileName, dot - 1)
Mid$(File.name83, 9) = Mid$(File.FileName, dot + 1)
Else
File.name83 = File.FileName
End If
File.name38 = Right$(File.name83, 3) + Left$(File.name83, 8)
End Sub
Function FileGetDateTime (FileSpec$, DateTime#)
'Initialization
Dim Regs As VBRegs, Rtn%, hFile%
Dim DtaSeg%, DtaOff%, Spec$
Dim Tim&, Dat&, File As FileDataType
'Insure valid file
If Not FileExists(FileSpec$) Then
FileGetDateTime = False
Exit Function
End If
'Open file
Spec$ = FileSpec$ + Chr$(0)
Regs.AX = &H3D00
Regs.DS = GetSegment(Spec$)
Regs.DX = GetOffset(Spec$)
Rtn = VBInt(&H21, Regs, Regs)
If Regs.cFlag Then
FileGetDateTime = False
Exit Function
Else
hFile = Regs.AX
End If
'Get date and time
Regs.AX = &H5700
Regs.BX = hFile
Rtn = VBInt(&H21, Regs, Regs)
If Regs.cFlag Then
FileGetDateTime = False
Exit Function
End If
'Interpret data
Tim& = Regs.CX
If Tim& < 0 Then Tim& = Tim& + 65536
File.second = (Tim& And &H1F) * 2
File.minute = (Tim& \ &H20) And &H3F
File.hour = (Tim& \ &H800) And &H1F
Dat& = Regs.DX
File.day = Dat& And &H1F
File.month = (Dat& \ &H20) And &HF
File.year = ((Dat& \ &H200) And &H1F) + 1980
DateTime = DateSerial(File.year, File.month, File.day) + TimeSerial(File.hour, File.minute, File.second)
'Close file
Regs.AX = &H3E00
Regs.BX = hFile
Rtn = VBInt(&H21, Regs, Regs)
If Not Regs.cFlag Then
FileGetDateTime = True
End If
End Function
Function FileRename% (OldName$, NewName$)
'Known Problem: Access Denied on WfW 3.11 hard disks!
'Initialization
Dim Regs As VBRegs, Rtn%
Dim nOldName$, nNewName$
'null terminate
nOldName$ = OldName$ + Chr$(0)
nNewName$ = NewName$ + Chr$(0)
'setup registers
Regs.AX = &H5600
Regs.DS = GetSegment(nOldName$)
Regs.DX = GetOffset(nOldName$)
Regs.ES = GetSegment(nNewName$)
Regs.DI = GetOffset(nNewName$)
Rtn = VBInt(&H21, Regs, Regs)
'test success
If Regs.cFlag Then
NewName$ = DosErrorMsg$(Regs.AX)
FileRename = False
Else
FileRename = True
End If
End Function
Function FileSetDateTime (FileSpec$, DateTime#)
'Initialization
Dim Regs As VBRegs, Rtn%, hFile%
Dim DtaSeg%, DtaOff%, Spec$
Dim Tim&, Dat&
'Insure valid file
If Not FileExists(FileSpec$) Then
FileSetDateTime = False
Exit Function
End If
'Open file
Spec$ = FileSpec$ + Chr$(0)
Regs.AX = &H3D00
Regs.DS = GetSegment(Spec$)
Regs.DX = GetOffset(Spec$)
Rtn = VBInt(&H21, Regs, Regs)
If Regs.cFlag Then
FileSetDateTime = False
Exit Function
Else
hFile = Regs.AX
End If
'Breakout data
Tim& = Hour(DateTime) * &H800 + Minute(DateTime) * &H20 + Second(DateTime) \ 2
If Tim& > &H7FFF Then
Regs.CX = Tim& - 65536
Else
Regs.CX = Tim&
End If
Dat& = (Year(DateTime) - 1980) * &H200 + Month(DateTime) * &H20 + Day(DateTime)
Regs.DX = Dat&
'Set date and time
Regs.AX = &H5701
Regs.BX = hFile
Rtn = VBInt(&H21, Regs, Regs)
If Regs.cFlag Then
FileSetDateTime = False
Exit Function
End If
'Close file
Regs.AX = &H3E00
Regs.BX = hFile
Rtn = VBInt(&H21, Regs, Regs)
If Not Regs.cFlag Then
FileSetDateTime = True
End If
End Function
Function FillDirArray (ByVal ThePath$, File() As FileDataType, Attribute%, IncludeCurrent%, IncludeParent%)
'Initialization
Dim Regs As VBRegs
Dim Rtn%, Num%
Dim DtaSeg%, DtaOff%
Dim DTA As DTAType
'The path must be a null terminated string
ThePath$ = Trim$(ThePath$) + Chr$(0)
'Get current DTA address
Regs.AX = &H2F00
Rtn% = VBInt(&H21, Regs, Regs)
DtaSeg = Regs.ES
DtaOff = Regs.BX
'Set dta address
Regs.AX = &H1A00
Regs.DS = UDTSegment(DTA)
Regs.DX = UDTOffset(DTA)
Rtn% = VBInt(&H21, Regs, Regs)
'Find first file match
Regs.AX = &H4E00
Regs.CX = Attribute
Regs.DS = GetSegment(ThePath$)
Regs.DX = GetOffset(ThePath$)
Rtn% = VBInt(&H21, Regs, Regs)
'The carry flag tells if a file was found or not
If Regs.cFlag And 1 Then 'Carry Flag Set
FillDirArray = Regs.AX
ReDim File(0) As FileDataType
Else 'Carry Flag Clear
'Proceed filling the array if FileFindFirst is successful
'Enter loop of FindFileNext calls
Do
If InStr(DTA.FileName, ".") = 1 Then
If InStr(2, DTA.FileName, ".") = 2 Then
If IncludeParent Then
ReDim Preserve File(0 To Num)
FileGetData DTA, File(Num)
Num = Num + 1
End If
ElseIf IncludeCurrent Then
ReDim Preserve File(0 To Num)
FileGetData DTA, File(Num)
Num = Num + 1
End If
Else
ReDim Preserve File(0 To Num)
FileGetData DTA, File(Num)
Num = Num + 1
End If
Regs.AX = &H4F00
Rtn% = VBInt(&H21, Regs, Regs)
Loop Until (Regs.cFlag And 1)
Num = Num - 1
'Return Success
FillDirArray = 0
End If
'Reset the original DTA
Regs.AX = &H1A00
Regs.DS = DtaSeg
Regs.DX = DtaOff
Rtn% = VBInt(&H21, Regs, Regs)
End Function
Sub FillDirTreeArray (DirArray$(), ByVal StartDir$, CurrentLevel%)
Static FileSpec$, Ndx%
If CurrentLevel = 0 Then
If InStr(LTrim$(StartDir$), " ") Then
StartDir$ = LTrim$(Left$(StartDir$, InStr(StartDir$, " ") - 1))
End If
If Right$(StartDir$, 1) <> "\" Then
StartDir$ = StartDir$ + "\"
End If
FileSpec$ = "*.*" + Chr$(0)
Ndx = 0
CurrentLevel = 1
ReDim DirArray(0 To 0)
End If
Dim ThePath$, ThisDir$
Dim Regs As VBRegs, Rtn%
Dim DtaSeg%, DtaOff%
Dim DTA As DTAType
ThePath$ = StartDir$ + FileSpec$
'Find the first match
'Get current DTA address
Regs.AX = &H2F00
Rtn% = VBInt(&H21, Regs, Regs)
DtaSeg = Regs.ES
DtaOff = Regs.BX
'Set dta address
Regs.AX = &H1A00
Regs.DS = UDTSegment(DTA)
Regs.DX = UDTOffset(DTA)
Rtn% = VBInt(&H21, Regs, Regs)
'Find first file match
Regs.AX = &H4E00
Regs.CX = attrAllDir
Regs.DS = GetSegment(ThePath$)
Regs.DX = GetOffset(ThePath$)
Rtn% = VBInt(&H21, Regs, Regs)
'Check if done with this branch
If Regs.cFlag And 1 Then 'No subdirectories
Exit Sub
End If
'Begin recursion *********************
Do
If Asc(DTA.Attribute) And attrDirectory Then
If Not InStr(DTA.FileName, ".") = 1 Then 'not Parent or Current dir
ThisDir$ = Left$(DTA.FileName, InStr(DTA.FileName, Chr$(0)) - 1)
DirArray(Ndx) = StartDir$ + ThisDir$
Ndx = Ndx + 1
ReDim Preserve DirArray(0 To Ndx)
'Look down further
FillDirTreeArray DirArray(), StartDir$ + ThisDir$ + "\", CurrentLevel + 1
'Setup for FileFindNext
Regs.CX = attrAllDir
Regs.DS = GetSegment(ThePath$)
Regs.DX = GetOffset(ThePath$)
End If
End If
'Search for next match
Regs.AX = &H4F00
Rtn% = VBInt(&H21, Regs, Regs)
If Regs.cFlag And 1 Then 'no more dirs
Exit Do
End If
Loop
'Reset the original DTA
Regs.AX = &H1A00
Regs.DS = DtaSeg
Regs.DX = DtaOff
Rtn% = VBInt(&H21, Regs, Regs)
End Sub